Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/code_lib/objlibr/objlib12/sample1/chngicon.frm

Text File | 1995-06-05 | 8KB | 296 lines

VERSION 2.00
Begin Form ChngIcon
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Double
   Caption         =   "Change Icon"
   ClientHeight    =   1845
   ClientLeft      =   2310
   ClientTop       =   2085
   ClientWidth     =   6750
   ControlBox      =   0   'False
   Height          =   2250
   Left            =   2250
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   123
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   450
   Top             =   1740
   Width           =   6870
   Begin PictureBox loader
      AutoRedraw      =   -1  'True
      BorderStyle     =   0  'None
      Height          =   495
      Left            =   270
      ScaleHeight     =   33
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   33
      TabIndex        =   9
      Top             =   1620
      Visible         =   0   'False
      Width           =   495
   End
   Begin HScrollBar hs
      Height          =   252
      LargeChange     =   288
      Left            =   1680
      SmallChange     =   36
      TabIndex        =   7
      Top             =   1215
      Width           =   3492
   End
   Begin PictureBox Pic1
      BackColor       =   &H00FFFFFF&
      Height          =   510
      Left            =   1680
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   230
      TabIndex        =   6
      Top             =   720
      Width           =   3480
      Begin PictureBox icns
         AutoRedraw      =   -1  'True
         BackColor       =   &H00FFFFFF&
         BorderStyle     =   0  'None
         DrawWidth       =   2
         Height          =   480
         Left            =   0
         ScaleHeight     =   32
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   218
         TabIndex        =   8
         Top             =   0
         Width           =   3264
      End
   End
   Begin TextBox Text1
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   285
      Left            =   1680
      TabIndex        =   1
      Text            =   "Text1"
      Top             =   240
      Width           =   3480
   End
   Begin CommandButton Command1
      BackColor       =   &H00000000&
      Caption         =   "&Browse..."
      Height          =   372
      Index           =   2
      Left            =   5400
      TabIndex        =   5
      Top             =   1200
      Width           =   1092
   End
   Begin CommandButton Command1
      BackColor       =   &H00000000&
      Cancel          =   -1  'True
      Caption         =   "Cancel"
      Height          =   372
      Index           =   1
      Left            =   5400
      TabIndex        =   4
      Top             =   720
      Width           =   1092
   End
   Begin CommandButton Command1
      BackColor       =   &H00000000&
      Caption         =   "OK"
      Default         =   -1  'True
      Height          =   372
      Index           =   0
      Left            =   5400
      TabIndex        =   3
      Top             =   240
      Width           =   1092
   End
   Begin Image deficon
      Height          =   480
      Left            =   900
      Picture         =   CHNGICON.FRX:0000
      Top             =   1650
      Visible         =   0   'False
      Width           =   480
   End
   Begin Label Label1
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "&Current Icon:"
      Height          =   192
      Index           =   1
      Left            =   360
      TabIndex        =   2
      Top             =   720
      Width           =   1128
   End
   Begin Label Label1
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "&Filename:"
      Height          =   192
      Index           =   0
      Left            =   648
      TabIndex        =   0
      Top             =   264
      Width           =   828
   End
End
Option Explicit
DefInt A-Z
Dim dirty%
Dim iconindex%
Dim i%, r%
Dim lastvalidfile$
'This form is a copy of the PM dialog, but the method
'of hiliting the selected icon differs:
'When a file is selected and its icons are
'extracted, they are blitted to a picturebox
'as a bitmap. For simplicity, the selected icon
'is indicated by a black square rather than by
'changing the background color.

Sub command1_click (Index As Integer)
Dim f$
Select Case Index
Case 0'ok
    'pass changes back to itemprops:
    gItem.iconpath = text1
    gItem.iconindex = iconindex
    GetIcon gItem.iconpath, gItem.iconindex
    Hide
Case 1
    Hide
Case 2  'browse
    f = GetFile(4, 4, 1): If f$ = "" Then Exit Sub
    text1 = f$
    LoadPics f$, 0
End Select
End Sub

Function ExtractIcons (f As Form, file$)
Dim n%, r%, inst%, i%, h%

h% = f.hWnd
inst% = GetWindowWord(h%, GWW_HINSTANCE)

'get total icons in file
n% = ExtractIcon(inst%, file$, -1)
If n < 1 Then
    MsgBox "The file contains no icons.": Exit Function
End If

'copy each to a bitmap
screen.MousePointer = 11
f.icns.Width = n * 36
For i% = 0 To n - 1
    GetIcon file$, i%
    r = BitBlt(f.icns.hDC, i * 36 + 1, 1, 32, 32, loader.hDC, 0, 0, SRCCOPY)
Next
f.icns.Refresh
ExtractIcons = n
screen.MousePointer = 0
End Function

Sub Form_Load ()
'in case icon size changes with screen resolution:
'note: this hasn't been tested on anything but 1...x7..
    Pic1.Move 112, 48, 6 * 36, 36
    icns.Move 0, 0, Pic1.Width, 34
    hs.Move Pic1.Left, Pic1.Top + Pic1.Height - 1, Pic1.Width
    text1.Width = Pic1.Width
'
text1 = Trim$(gItem.iconpath)
If text1 = "" Then command1_click 2'prompt for file
'
lastvalidfile$ = text1
LoadPics gItem.iconpath, gItem.iconindex
End Sub

Sub Form_Paint ()
RaiseForm Me
End Sub

Sub GetIcon (file$, ndx%)
Dim h%, r%, inst%
inst% = GetWindowWord(hWnd, GWW_HINSTANCE)
h% = ExtractIcon(inst%, file$, ndx%)
loader.Cls
If h% > 1 Then 'has icons
    r% = DrawIcon(loader.hDC, 0, 0, h%)
Else
    loader = deficon
End If
End Sub

Sub hs_Change ()
icns.Left = -hs.Value
End Sub

Sub icns_DblClick ()
command1_click 0
End Sub

Sub icns_mousedown (Button As Integer, Shift As Integer, X As Single, Y As Single)
'erase old hilite
icns.Line (iconindex * 36, 0)-(iconindex * 36 + 34, 34), icns.BackColor, B
'get absolute index
iconindex = X \ 36
'draw new hilite
icns.Line (iconindex * 36, 0)-(iconindex * 36 + 34, 34), &H0&, B
End Sub

Sub LoadPics (f$, ndx%)
Dim total%
'
If f = "" Then Exit Sub
'check path, then try to load icons
If FileLen(f$) Then
    lastvalidfile$ = f$
Else
    MsgBox "Cannot open file."
    text1 = lastvalidfile$: Exit Sub
End If

'copy file's icons to icns picbox
total% = ExtractIcons(Me, f$)
If total% = 0 Then Exit Sub
'
'set scroll range
If total% > 8 Then
    hs.Enabled = -1
    hs.Max = (total - 8) * 36
Else
    hs.Enabled = 0
End If
'
'hilite it
iconindex = 0
icns_mousedown 0, 0, ndx% * 36 + 3, 0
End Sub

Sub Text1_Change ()
dirty = -1
End Sub

Sub Text1_GotFocus ()
dirty = 0
End Sub

Sub Text1_LostFocus ()
If dirty% Then
        LoadPics CStr(text1), 0
End If
End Sub